home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Mines / MineTypes.icl < prev   
Encoding:
Modula Implementation  |  1997-04-25  |  9.5 KB  |  315 lines  |  [TEXT/3PRM]
  1. implementation module MineTypes
  2.  
  3. import StdInt, StdMisc, StdBool, StdString, StdList, StdTuple, StdEnum, StdFile
  4. import deltaPicture, deltaFont, deltaWindow, deltaSystem
  5. import Random
  6.  
  7. ::    Minefield    :== [[Spot]]
  8. ::    Spot        =    Mine        Visibility
  9.                 |    Empty Int    Visibility
  10. ::    Visibility    =    Visible
  11.                 |    Invisible
  12. ::    Pebbles        :==    [Position]
  13. ::    Position    :==    (!Int,!Int)
  14. ::    Dimension    :==    (!Int,!Int)
  15. ::    Time        =    Running Int
  16.                 |    Off
  17. ::    BestTimes    :== (ThreeBest, ThreeBest, ThreeBest)
  18. ::    ThreeBest    :== (String,Int,String,Int,String,Int)
  19.  
  20. ::    *MinesBest    :== (Files, BestTimes)
  21.  
  22. EasyDim            :== (8,  8)
  23. EasyMines        :== 10
  24. InterDim        :== (16,16)
  25. InterMines        :== 40
  26. HardDim            :== (30,16)
  27. HardMines        :== 99
  28.  
  29. SizeArea        :== 14
  30.  
  31. GetTime :: !Time -> Int
  32. GetTime (Running time)    = time
  33. GetTime _                = 0
  34.  
  35. /*    Drawing functions:
  36. */
  37.  
  38. DrawCorrectnessPebble :: Pebbles Position !Spot !Picture -> Picture
  39. DrawCorrectnessPebble _ _ (Mine _) picture
  40.                                 = picture
  41. DrawCorrectnessPebble pebble pos _ picture
  42. |    not (isMember pos pebble)    = picture
  43. #    picture                        = SetPenSize    (2,2)                picture
  44.     picture                        = MovePenTo        base                picture
  45.     picture                        = LinePen        (neg_size,neg_size)    picture
  46.     picture                        = MovePen        (size,0)            picture
  47.     picture                        = LinePen        (neg_size,size)        picture
  48.     picture                        = SetPenNormal                        picture
  49. |    otherwise                    = picture
  50. where
  51.     base                        = ScaleVector size pos
  52.     size                        = SizeArea
  53.     neg_size                    = ~size
  54.  
  55. DrawNrMines :: !Font !Int !Dimension !Picture -> Picture
  56. DrawNrMines font nr_mines dim=:(col,row) picture
  57. #    picture                        = EraseRectangle    (base_rect, (x_max, 0))    picture
  58.     picture                        = MovePenTo            base_text                picture
  59.     picture                        = DrawString        text                    picture
  60. =    picture
  61. where
  62.     base_rect                    = TranslatePoint base_text (0,descent)
  63.     base_text                    = ScaleVector SizeArea (col+1,1)
  64.     (_,(x_max,_))                = WindowPictDomain dim
  65.     (_,descent,_,_)                = FontMetrics font
  66.     text                        = "Mines: "+++toString nr_mines
  67.  
  68. DrawTime :: !Font !Int !Dimension !Picture -> Picture
  69. DrawTime font time (col,row) picture
  70. #    picture                        = EraseRectangle    (base_rect, base_rect`)    picture
  71.     picture                        = MovePenTo            base_text                picture
  72.     picture                        = DrawString        text                    picture
  73. =    picture
  74. where
  75.     base_text                    = ScaleVector SizeArea (col+1,row)
  76.     base_rect`                    = TranslatePoint base_rect (string_width, ~string_height)
  77.     base_rect                    = TranslatePoint base_text (0, descent)
  78.     string_height                = ascent+descent+leading
  79.     string_width                = FontStringWidth text font
  80.     (ascent,descent,_,leading)    = FontMetrics font
  81.     text                        = "Time: "+++toString time
  82.  
  83. DrawPebble :: !Position !Picture -> Picture
  84. DrawPebble position picture
  85. =    DrawCircle circle (EraseCircle circle picture)
  86. where
  87.     circle        = CirclePosition position
  88.  
  89. DrawEmptyArea :: !Position !Picture -> Picture
  90. DrawEmptyArea (x,y) picture
  91. #    picture        = SetPenColour    (RGB 0.45 0.7 0.45)    picture
  92.     picture        = FillRectangle    (base1,base2)        picture
  93.     picture        = SetPenColour    BlackColour            picture
  94. =    picture
  95. where
  96.     base        = ScaleVector size (x-1, y)
  97.     base1        = TranslatePoint base (1,-1)
  98.     base2        = TranslatePoint base (TranslatePoint (size,~size) (-2,2))
  99.     size        = SizeArea
  100.  
  101. DrawSpot :: !Position !Spot !Picture -> Picture
  102. DrawSpot (x,y) (Empty n Visible) picture
  103. #    picture        = EraseRectangle (base1,base2) picture
  104. |    n==0        = picture
  105. #    picture        = MovePenTo basenr picture
  106.     picture        = DrawString (toString n) picture
  107. |    otherwise    = picture
  108. where
  109.     base        = ScaleVector size (x-1, y)
  110.     base1        = TranslatePoint base (1,-1)
  111.     base2        = TranslatePoint base (TranslatePoint (size,~size) (-1,1))
  112.     basenr        = TranslatePoint base (2,-2)
  113.     size        = SizeArea
  114. DrawSpot pos=:(x,y) (Mine Visible) picture
  115. #    picture        = EraseRectangle (base1,base2)        picture
  116.     picture        = FillCircle (CirclePosition pos)    picture
  117. =    picture
  118. where
  119.     base        = ScaleVector size (x-1,y)
  120.     base1        = TranslatePoint base (1,-1)
  121.     base2        = TranslatePoint base (TranslatePoint (size,~size) (-1,1))
  122.     size        = SizeArea
  123. DrawSpot pos _ picture
  124. =    DrawEmptyArea pos picture
  125.  
  126. DrawAnySpot :: !Position !Spot !Picture -> Picture
  127. DrawAnySpot (x,y) (Empty n v) picture
  128. #    picture        = EraseRectangle (base1,base2) picture
  129. |    n==0        = picture
  130. #    picture        = MovePenTo basenr picture
  131.     picture        = DrawString (toString n) picture
  132. |    otherwise    = picture
  133. where
  134.     base        = ScaleVector size (x-1, y)
  135.     base1        = TranslatePoint base (1,-1)
  136.     base2        = TranslatePoint base (TranslatePoint (size,~size) (-1,1))
  137.     basenr        = TranslatePoint base (2,-2)
  138.     size        = SizeArea
  139. DrawAnySpot pos=:(x,y) (Mine v) picture
  140. #    picture        = EraseRectangle (base1,base2)        picture
  141.     picture        = FillCircle (CirclePosition pos)    picture
  142. =    picture
  143. where
  144.     base        = ScaleVector size (x-1, y)
  145.     base1        = TranslatePoint base (1,-1)
  146.     base2        = TranslatePoint base (TranslatePoint (size,~size) (-1,1))
  147.     size        = SizeArea
  148.  
  149. CirclePosition :: !Position -> Circle
  150. CirclePosition position
  151. =    (center, halfsize-2)
  152. where
  153.     center        = TranslatePoint (neg_halfsize, neg_halfsize) (ScaleVector size position)
  154.     size        = SizeArea
  155.     halfsize    = size/2
  156.     neg_halfsize= ~halfsize
  157.  
  158. DrawGrid :: !Dimension !Picture -> Picture
  159. DrawGrid (col,row) picture
  160. #    picture        = MovePenTo corner1    picture
  161.     picture        = DrawLines corner1 row (size*col,0) (0,size)    picture
  162.     picture        = MovePenTo corner1                                picture
  163.     picture        = DrawLines corner1 col (0,size*row) (size,0)    picture
  164.     picture        = MovePenTo corner2                                picture
  165.     picture        = DrawLines corner2 row (size*col,0) (0,size)    picture
  166.     picture        = MovePenTo corner2                                picture
  167.     picture        = DrawLines corner2 col (0,size*row) (size,0)    picture
  168. =    picture
  169. where
  170.     corner2        = (-1, -1)
  171.     corner1        = (0, 0)
  172.     size        = SizeArea
  173.     
  174.     DrawLines :: !Position !Int !Vector !Vector !Picture -> Picture
  175.     DrawLines base nr_lines relative to_next_base picture
  176.     #    picture        = LinePen    relative picture
  177.     |    nr_lines==0    = picture
  178.     #    picture        = MovePenTo    next_base picture
  179.         picture        = DrawLines next_base (nr_lines-1) relative to_next_base picture
  180.     |    otherwise    = picture
  181.     where
  182.         next_base    = TranslatePoint base to_next_base
  183.  
  184.  
  185. /*    Functions on a Minefield:
  186. */
  187.  
  188. SowMines ::    !Int !Dimension !RandomSeed -> (!Minefield,!RandomSeed)
  189. SowMines nr_mines dimension=:(col,row) seed
  190. =    (PlantMines uniqueMines dimension, newSeed)
  191. where
  192.     (uniqueMines,newSeed)    = UniqueMines (col*row) nr_mines [(x,y) \\ x<-[1..col], y<-[1..row]] seed
  193.     
  194.     UniqueMines :: !Int !Int ![Position] !RandomSeed -> (![Position], !RandomSeed)
  195.     UniqueMines max_mines nr_mines mines seed
  196.     |    nr_mines==0    = ([],seed)
  197.     |    otherwise    = ([element:uniqueMines],seed2)
  198.     with
  199.         (element,mines1)    = GetIndex (random mod max_mines) mines
  200.         (random, seed1)        = Random seed
  201.         (uniqueMines,seed2)    = UniqueMines (max_mines-1) (nr_mines-1) mines1 seed1
  202.         
  203.         GetIndex :: !Int ![x] -> (!x,![x])
  204.         GetIndex n xs        = (x,before++after)    where    (before,[x:after])    = splitAt n xs
  205.     
  206.     PlantMines :: [Position] !Position -> Minefield
  207.     PlantMines _ (0,_) = []
  208.     PlantMines mines pos=:(col,row)
  209.     =    [PlantColMines mines pos : PlantMines mines (col-1,row)]
  210.     where
  211.         PlantColMines :: [Position] !Position -> [Spot]
  212.         PlantColMines _ (_,0) = []
  213.         PlantColMines mines pos=:(col,row)
  214.         =    [PlantMine mines pos : PlantColMines mines (col,row-1)]
  215.         where
  216.             PlantMine :: ![Position] !Position -> Spot
  217.             PlantMine mines pos
  218.             |    isMember pos mines    = Mine Invisible
  219.             |    otherwise            = Empty (CountNeighbourMines mines pos) Invisible
  220.             where
  221.                 CountNeighbourMines :: ![Position] !Position -> Int
  222.                 CountNeighbourMines [mine:mines] pos
  223.                 |    IsNeighbour mine pos    = neighbours+1
  224.                 |    otherwise                = neighbours
  225.                 where
  226.                     neighbours                = CountNeighbourMines mines pos
  227.                     
  228.                     IsNeighbour :: !Position !Position -> Bool
  229.                     IsNeighbour (x,y) (x`,y`)
  230.                     |    dx==0        = dy==1
  231.                     |    dx==1        = dy<=1
  232.                     |    otherwise    = False
  233.                     where
  234.                         dx            = abs (x-x`)
  235.                         dy            = abs (y-y`)
  236.                 CountNeighbourMines _ _        = 0 
  237.  
  238. GetSpot :: !Position !Minefield -> Spot
  239. GetSpot (col,row) minefield = minefield!!(col-1)!!(row-1)
  240.  
  241. RevealSpot :: !Position !Minefield -> (!Spot,!Minefield)
  242. RevealSpot (col,row) [col_mines : minefield]
  243. |    col==1        = (spot, [col : minefield])
  244.                 with
  245.                     (spot,col)    = ColRevealSpot row col_mines
  246.                     
  247.                     ColRevealSpot :: !Int ![Spot] -> (!Spot,![Spot])
  248.                     ColRevealSpot 1 [Empty n Invisible:spots]
  249.                     =    (spot, [spot:spots])
  250.                     where
  251.                         spot    = Empty n Visible
  252.                     ColRevealSpot 1 l=:[spot:_]
  253.                     =    (spot, l)
  254.                     ColRevealSpot n [spot:spots]
  255.                     =    (spot1, [spot:spots1])
  256.                     where
  257.                         (spot1, spots1)    = ColRevealSpot (n-1) spots
  258.                     ColRevealSpot _ _
  259.                     =    abort "Error in rule ColRevealSpot (module MineTypes): invalid index"
  260. |    otherwise    = (spot, [col_mines : minefield`])
  261.                 with
  262.                     (spot, minefield`)= RevealSpot (col-1, row) minefield
  263. RevealSpot _ _    = abort "Error in rule RevealSpot (module MineTypes): invalid Position"
  264.  
  265.  
  266. /*    Functions on Spots:
  267. */
  268.  
  269. NulSpot :: !Spot -> Bool
  270. NulSpot (Empty 0 _)                = True
  271. NulSpot _                        = False
  272.  
  273. MineSpot :: !Spot -> Bool
  274. MineSpot (Mine _)                = True
  275. MineSpot _                        = False
  276.  
  277. InvisibleSpot :: !Spot -> Bool
  278. InvisibleSpot (Empty _ Visible)    = False
  279. InvisibleSpot _                    = True
  280.  
  281.  
  282. /*    Functions on Pebbles:
  283. */
  284.  
  285. RemovePebble :: !Position !Pebbles -> Pebbles
  286. RemovePebble pos=:(p,q) [pebble=:(x,y):pebbles]
  287. |    p==x && q==y    = pebbles
  288. |    otherwise        = [pebble:RemovePebble pos pebbles]
  289. RemovePebble _ _    = []
  290.  
  291.  
  292. /*    Dimension defining functions:
  293. */
  294.  
  295. WindowPictDomain :: !Dimension -> PictureDomain
  296. WindowPictDomain (col,row)
  297. =    ((0,0), (max (DomainWidth  col) (DomainWidth 8),max (DomainHeight row) (DomainHeight 8)))
  298.  
  299. DomainWidth :: !Int -> Int
  300. DomainWidth col = (col+1)*SizeArea+90
  301.  
  302. DomainHeight :: !Int -> Int
  303. DomainHeight row = row*SizeArea+1
  304.  
  305. MaxDimension :: Dimension
  306. MaxDimension    = ((maxw-90)/SizeArea-1,(maxh-1)/SizeArea)
  307. where
  308.     (maxw,maxh)    = MaxFixedWindowSize
  309.  
  310. ScaleVector :: !Int !Vector -> Vector
  311. ScaleVector k (wx,wy) = (k*wx, k*wy)
  312.  
  313. TranslatePoint :: !Point !Vector -> Point
  314. TranslatePoint (px,py) (vx,vy) = (px+vx,py+vy)
  315.